home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / glisp / glisp.000 / GLISP.UNIX.TAR / closunix / clos_lf3.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-04-03  |  24.2 KB  |  921 lines
  1. /*                 GRAPHIC LISP            */
  2. /*        Scritto nel 1991-94 da Zoia Andrea Michele     */
  3. /*        Via Pergola #1 Tirano (SO) Tel. 0342-704210    */
  4. /* file clos_lf3.c */
  5.  
  6. #include "clos.h"
  7.  
  8. /* funzioni matematiche ************************************/
  9. /* SIN    , COS    , TAN   , ASIN   , ACOS  , ATAN , SINH  */
  10. /* COSH   , TANH   , EXP   , LOG    , LOG10 , SQRT         */
  11. /* PLUS   , MINUS  , MULT  , DIV    , PLUSONE , MINUSONE   */
  12. /* MAX    , MIN    , ABS   , FLOAT  , ROUND   , REM        */
  13. /***********************************************************/
  14.  
  15. /* nota ***********************/
  16. /* +  รจ tradotto in PLUS      */
  17. /* -      ,,        MINUS     */
  18. /* *      ,,        MULT      */
  19. /* /      ,,        DIV       */
  20. /* 1+     ,,        PLUSONE   */
  21. /* 1-     ,,        MINUSONE  */
  22. /******************************/
  23.  
  24.  
  25. #define M_SIN   0
  26. #define M_COS   1
  27. #define M_TAN   2
  28. #define M_ASIN  3
  29. #define M_ACOS  4
  30. #define M_ATAN  5
  31. #define M_SINH  6
  32. #define M_COSH  7
  33. #define M_TANH  8
  34. #define M_EXP   9
  35. #define M_LOG   10
  36. #define M_LOG10 11
  37. #define M_SQRT  12
  38.  
  39. #define MAX_M_FUNCS 13
  40.  
  41. void general_lf_math LF_PARAMSD;
  42. int  math_ratcnvt();
  43.  
  44.  
  45. n_real (*math_funcs[MAX_M_FUNCS])()={
  46.  sin  ,cos  ,tan  ,
  47.  asin ,acos ,atan ,
  48.  sinh ,cosh ,tanh ,
  49.  exp  ,log  ,log10,
  50.  sqrt
  51. };
  52.  
  53.  
  54. void lf_sin LF_PARAMS
  55. {
  56.  general_lf_math(nin,nout,genv,lenv,M_SIN);
  57. }
  58. void lf_cos LF_PARAMS
  59. {
  60.  general_lf_math(nin,nout,genv,lenv,M_COS);
  61. }
  62. void lf_tan LF_PARAMS
  63. {
  64.  general_lf_math(nin,nout,genv,lenv,M_TAN);
  65. }
  66. void lf_asin LF_PARAMS
  67. {
  68.  general_lf_math(nin,nout,genv,lenv,M_ASIN);
  69. }
  70. void lf_acos LF_PARAMS
  71. {
  72.  general_lf_math(nin,nout,genv,lenv,M_ACOS);
  73. }
  74. void lf_atan LF_PARAMS
  75. {
  76.  general_lf_math(nin,nout,genv,lenv,M_ATAN);
  77. }
  78. void lf_sinh LF_PARAMS
  79. {
  80.  general_lf_math(nin,nout,genv,lenv,M_SINH);
  81. }
  82. void lf_cosh LF_PARAMS
  83. {
  84.  general_lf_math(nin,nout,genv,lenv,M_COSH);
  85. }
  86. void lf_tanh LF_PARAMS
  87. {
  88.  general_lf_math(nin,nout,genv,lenv,M_TANH);
  89. }
  90. void lf_exp LF_PARAMS
  91. {
  92.  general_lf_math(nin,nout,genv,lenv,M_EXP);
  93. }
  94. void lf_log LF_PARAMS
  95. {
  96.  general_lf_math(nin,nout,genv,lenv,M_LOG);
  97. }
  98. void lf_log10 LF_PARAMS
  99. {
  100.  general_lf_math(nin,nout,genv,lenv,M_LOG10);
  101. }
  102. void lf_sqrt LF_PARAMS
  103. {
  104.  general_lf_math(nin,nout,genv,lenv,M_SQRT);
  105. }
  106.  
  107. void general_lf_math LF_PARAMS
  108. {
  109.  /* fl qui' e' usato come un indice per l'array di funzioni matematiche */
  110.  
  111.  if(IS_CONS(nin)){
  112.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  113.    nin=calc_pointer(nout);
  114.    if( IS_VALUE_AND_NUMBER(nin) ){
  115.      nout->node=node_make();
  116.      nout->type=P_ALLNODE;
  117.      switch(GET_VTYPE(nin)){
  118.        case NT_INTEGER:
  119.          INTEGER(nout->node)=(n_int)(*math_funcs[fl])((double)INTEGER(nin));
  120.      TYPE(nout->node)|=NT_IS_VALUE+NT_INTEGER;
  121.          return;
  122.        case NT_REAL:
  123.          REAL(nout->node)=(n_real)(*math_funcs[fl])((double)REAL(nin));
  124.          TYPE(nout->node)|=NT_IS_VALUE+NT_REAL;
  125.          return;
  126.        case NT_RATIO:
  127.          REAL(nout->node)=(n_real)(*math_funcs[fl])
  128.                         ((double)RATIO_NUM(nin)/(double)RATIO_DEN(nin));
  129.          TYPE(nout->node)|=NT_IS_VALUE+NT_REAL;
  130.          return;
  131.      }
  132.    }
  133.    error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  134.  }
  135.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  136. }
  137.  
  138. int math_ratcnvt(num,den,integ)
  139. n_int num;
  140. n_int den;
  141. n_int  *integ;
  142. {
  143.  double tmp;
  144.  if(modf((double)num/(double)den,&tmp))return FALSE;
  145.  *integ=(n_int)tmp; /*guardare se si puo' usare tmp */
  146.  return TRUE;
  147. }
  148.  
  149. #define TF_INT 0
  150. #define TF_RAT 1
  151. #define TF_FLO 2
  152.  
  153. void lf_plus LF_PARAMS
  154. {
  155.  int argcounter=0;
  156.  int type_flag=TF_INT;
  157.  n_int intval=0;/* el.neutro */
  158.  n_real realval;
  159.  n_int rval_num;
  160.  n_int rval_den;
  161.  node n,ni=nin;
  162.  
  163.  while(nin!=NIL){
  164.    if(IS_CONS(nin)){
  165.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  166.      n=calc_pointer(nout);
  167.      if(IS_VALUE_AND_NUMBER(n)){
  168.        switch(GET_VTYPE(n)){
  169.          case NT_INTEGER:
  170.            if(type_flag==TF_INT){
  171.              intval+=INTEGER(n);
  172.              break;
  173.            }
  174.            if(type_flag==TF_RAT){
  175.              rval_num+=INTEGER(n)*rval_den;
  176.              break;
  177.            }
  178.            realval+=(n_real)INTEGER(n);
  179.            break;
  180.          case NT_RATIO:
  181.            if(type_flag==TF_INT){
  182.              type_flag=TF_RAT;
  183.              rval_den=RATIO_DEN(n);
  184.              rval_num=RATIO_NUM(n)+intval*rval_den;
  185.              break;
  186.            }
  187.            if(type_flag==TF_RAT){
  188.              rval_num=rval_num*RATIO_DEN(n)+rval_den*RATIO_NUM(n);
  189.              rval_den*=RATIO_DEN(n);
  190.              break;
  191.            }
  192.            realval+=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  193.            break;
  194.          case NT_REAL:
  195.            if(type_flag==TF_INT){
  196.              type_flag=TF_FLO;
  197.              realval=(n_real)intval+REAL(n);
  198.              break;
  199.            }
  200.            if(type_flag==TF_RAT){
  201.              type_flag=TF_FLO;
  202.              realval=(n_real)rval_num/(n_real)rval_den+REAL(n);
  203.              break;
  204.            }
  205.            realval+=REAL(n);
  206.            break;
  207.        }/*switch*/
  208.      }else{
  209.        error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  210.      }/*isnumber*/
  211.    }else{
  212.        error(E_BADLIST,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&ni);
  213.    }/*iscons*/
  214.    nin=CONSRIGHT(nin);
  215.    argcounter++;
  216.  }
  217.  if(argcounter<1)
  218.    error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&ni);
  219.  nout->node=node_make();
  220.  nout->type=P_ALLNODE;
  221.  if(type_flag==TF_INT){
  222.     TYPE(nout->node)|=NT_IS_VALUE+NT_INTEGER;
  223.     INTEGER(nout->node)=intval;
  224.     return;
  225.  }
  226.  if(type_flag==TF_RAT){
  227.     if(math_ratcnvt(rval_num,rval_den,&INTEGER(nout->node))){
  228.         TYPE(nout->node)|=NT_IS_VALUE+NT_INTEGER;
  229.         return;
  230.     }
  231.     TYPE(nout->node)|=NT_IS_VALUE+NT_RATIO;
  232.     RATIO_NUM(nout->node)=rval_num;
  233.     RATIO_DEN(nout->node)=rval_den;
  234.     return;
  235.  }
  236.  TYPE(nout->node)|=NT_IS_VALUE+NT_REAL;
  237.  REAL(nout->node)=realval;
  238. }
  239.  
  240.  
  241. void lf_minus LF_PARAMS
  242. {
  243.  int argcounter=0;
  244.  int type_flag=TF_INT;
  245.  n_int intval;
  246.  n_real realval;
  247.  n_int rval_num;
  248.  n_int rval_den;
  249.  node n,ni=nin;
  250.  
  251.  while(nin!=NIL){
  252.    if(IS_CONS(nin)){
  253.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  254.      n=calc_pointer(nout);
  255.      if(IS_VALUE_AND_NUMBER(n)){
  256.        switch(GET_VTYPE(n)){
  257.          case NT_INTEGER:
  258.            if(type_flag==TF_INT){
  259.              if(argcounter){
  260.           intval-=INTEGER(n);
  261.              }
  262.              else{
  263.               intval=INTEGER(n);
  264.              }
  265.              break;
  266.            }
  267.            if(type_flag==TF_RAT){
  268.          rval_num-=INTEGER(n)*rval_den;
  269.              break;
  270.            }
  271.        realval-=(n_real)INTEGER(n);
  272.            break;
  273.          case NT_RATIO:
  274.            if(type_flag==TF_INT){
  275.              type_flag=TF_RAT;
  276.              if(argcounter){
  277.                rval_den=RATIO_DEN(n);
  278.                rval_num=RATIO_NUM(n)-intval*rval_den;
  279.              }else{
  280.                rval_num=RATIO_NUM(n);
  281.                rval_den=RATIO_DEN(n);
  282.              }
  283.              break;
  284.            }
  285.            if(type_flag==TF_RAT){
  286.              rval_num=rval_num*RATIO_DEN(n)-rval_den*RATIO_NUM(n);
  287.              rval_den*=RATIO_DEN(n);
  288.              break;
  289.            }
  290.        realval-=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  291.            break;
  292.          case NT_REAL:
  293.            if(type_flag==TF_INT){
  294.              type_flag=TF_FLO;
  295.              if(argcounter){
  296.               realval=(n_real)intval-REAL(n);
  297.              }else{
  298.               realval=REAL(n);
  299.              }
  300.              break;
  301.            }
  302.            if(type_flag==TF_RAT){
  303.              type_flag=TF_FLO;
  304.              realval=(n_real)rval_num/(n_real)rval_den-REAL(n);
  305.              break;
  306.            }
  307.            realval-=REAL(n);
  308.            break;
  309.        }/*switch*/
  310.      }else{
  311.        error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  312.      }/*isnumber*/
  313.    }else{
  314.        error(E_BADLIST,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&ni);
  315.    }/*iscons*/
  316.    nin=CONSRIGHT(nin);
  317.    argcounter++;
  318.  }
  319.  if(argcounter<1)
  320.    error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&ni);
  321.  if(argcounter==1){
  322.    if(type_flag==TF_INT){
  323.     intval*=-1;
  324.    }
  325.    else{
  326.     if(type_flag==TF_RAT){
  327.      rval_num*=-1;
  328.     }
  329.     else{
  330.      realval*=-1;
  331.     }
  332.    }
  333.  }
  334.  nout->node=node_make();
  335.  nout->type=P_ALLNODE;
  336.  if(type_flag==TF_INT){
  337.     TYPE(nout->node)|=NT_IS_VALUE+NT_INTEGER;
  338.     INTEGER(nout->node)=intval;
  339.     return;
  340.  }
  341.  if(type_flag==TF_RAT){
  342.     if(math_ratcnvt(rval_num,rval_den,&INTEGER(nout->node))){
  343.         TYPE(nout->node)|=NT_IS_VALUE+NT_INTEGER;
  344.         return;
  345.     }
  346.     TYPE(nout->node)|=NT_IS_VALUE+NT_RATIO;
  347.     RATIO_NUM(nout->node)=rval_num;
  348.     RATIO_DEN(nout->node)=rval_den;
  349.     return;
  350.  }
  351.  TYPE(nout->node)|=NT_IS_VALUE+NT_REAL;
  352.  REAL(nout->node)=realval;
  353. }
  354.  
  355.  
  356. void lf_mult LF_PARAMS
  357. {
  358.  int argcounter=0;
  359.  int type_flag=TF_INT;
  360.  n_int intval=1; /*el.neutro*/
  361.  n_real realval;
  362.  n_int rval_num;
  363.  n_int rval_den;
  364.  node n,ni=nin;
  365.  
  366.  while(nin!=NIL){
  367.    if(IS_CONS(nin)){
  368.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  369.      n=calc_pointer(nout);
  370.      if(IS_VALUE_AND_NUMBER(n)){
  371.        switch(GET_VTYPE(n)){
  372.          case NT_INTEGER:
  373.            if(type_flag==TF_INT){
  374.              intval*=INTEGER(n);
  375.              break;
  376.            }
  377.            if(type_flag==TF_RAT){
  378.          rval_num*=INTEGER(n);
  379.              break;
  380.            }
  381.        realval*=(n_real)INTEGER(n);
  382.            break;
  383.          case NT_RATIO:
  384.            if(type_flag==TF_INT){
  385.              type_flag=TF_RAT;
  386.              rval_den=RATIO_DEN(n);
  387.              rval_num=RATIO_NUM(n)*intval;
  388.              break;
  389.            }
  390.            if(type_flag==TF_RAT){
  391.              rval_num*=RATIO_NUM(n);
  392.              rval_den*=RATIO_DEN(n);
  393.              break;
  394.            }
  395.        realval*=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  396.            break;
  397.          case NT_REAL:
  398.            if(type_flag==TF_INT){
  399.              type_flag=TF_FLO;
  400.              realval=(n_real)intval*REAL(n);
  401.              break;
  402.            }
  403.            if(type_flag==TF_RAT){
  404.              type_flag=TF_FLO;
  405.              realval=(n_real)rval_num/(n_real)rval_den*REAL(n);
  406.              break;
  407.            }
  408.            realval*=REAL(n);
  409.            break;
  410.        }/*switch*/
  411.      }else{
  412.        error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  413.      }/*isnumber*/
  414.    }else{
  415.        error(E_BADLIST,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&ni);
  416.    }/*iscons*/
  417.    nin=CONSRIGHT(nin);
  418.    argcounter++;
  419.  }
  420.  if(argcounter<2)
  421.    error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&ni);
  422.  nout->node=node_make();
  423.  nout->type=P_ALLNODE;
  424.  if(type_flag==TF_INT){
  425.     TYPE(nout->node)|=NT_IS_VALUE+NT_INTEGER;
  426.     INTEGER(nout->node)=intval;
  427.     return;
  428.  }
  429.  if(type_flag==TF_RAT){
  430.     if(math_ratcnvt(rval_num,rval_den,&INTEGER(nout->node))){
  431.         TYPE(nout->node)|=NT_IS_VALUE+NT_INTEGER;
  432.         return;
  433.     }
  434.     TYPE(nout->node)|=NT_IS_VALUE+NT_RATIO;
  435.     RATIO_NUM(nout->node)=rval_num;
  436.     RATIO_DEN(nout->node)=rval_den;
  437.     return;
  438.  }
  439.  TYPE(nout->node)|=NT_IS_VALUE+NT_REAL;
  440.  REAL(nout->node)=realval;
  441. }
  442.  
  443.  
  444. void lf_div LF_PARAMS
  445. {
  446.  int argcounter=0;
  447.  int type_flag=TF_RAT;
  448.  n_real realval;
  449.  n_int rval_num;
  450.  n_int rval_den;
  451.  node n,ni=nin;
  452.  
  453.  while(nin!=NIL){
  454.    if(IS_CONS(nin)){
  455.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  456.      n=calc_pointer(nout);
  457.      if(IS_VALUE_AND_NUMBER(n)){
  458.        switch(GET_VTYPE(n)){
  459.          case NT_INTEGER:
  460.            if(argcounter && !INTEGER(n))
  461.               error(E_DIVBYZERO,ERR_PVOID|ERR_MERROR|ERR_TBLVL,NULL);
  462.            if(type_flag==TF_RAT){
  463.              if(argcounter){
  464.           rval_den*=INTEGER(n);
  465.              }
  466.              else{
  467.               rval_num=INTEGER(n);
  468.               rval_den=1;
  469.              }
  470.              break;
  471.            }
  472.        realval/=(n_real)INTEGER(n);
  473.            break;
  474.          case NT_RATIO:
  475.            if(argcounter && !RATIO_NUM(n))
  476.               error(E_DIVBYZERO,ERR_PVOID|ERR_MERROR|ERR_TBLVL,NULL);
  477.            if(type_flag==TF_RAT){
  478.             if(argcounter){
  479.              rval_num*=RATIO_DEN(n);
  480.              rval_den*=RATIO_NUM(n);
  481.             }else{
  482.              rval_num=RATIO_NUM(n);
  483.              rval_den=RATIO_DEN(n);
  484.             }
  485.             break;
  486.            }
  487.        realval*=(n_real)RATIO_DEN(n)/(n_real)RATIO_NUM(n);
  488.            break;
  489.          case NT_REAL:
  490.            if(argcounter && !REAL(n))
  491.               error(E_DIVBYZERO,ERR_PVOID|ERR_MERROR|ERR_TBLVL,NULL);
  492.            if(type_flag==TF_RAT){
  493.              type_flag=TF_FLO;
  494.              if(argcounter){
  495.               realval=(n_real)rval_num/(n_real)rval_den/REAL(n);
  496.              }else{
  497.               realval=REAL(n);
  498.              }
  499.              break;
  500.            }
  501.            realval/=REAL(n);
  502.            break;
  503.        }/*switch*/
  504.      }else{
  505.        error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  506.      }/*isnumber*/
  507.    }else{
  508.        error(E_BADLIST,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&ni);
  509.    }/*iscons*/
  510.    nin=CONSRIGHT(nin);
  511.    argcounter++;
  512.  }
  513.  if(argcounter<2)
  514.    error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&ni);
  515.  nout->node=node_make();
  516.  nout->type=P_ALLNODE;
  517.  if(type_flag==TF_RAT){
  518.     if(math_ratcnvt(rval_num,rval_den,&INTEGER(nout->node))){
  519.         TYPE(nout->node)|=NT_IS_VALUE+NT_INTEGER;
  520.         return;
  521.     }
  522.     TYPE(nout->node)|=NT_IS_VALUE+NT_RATIO;
  523.     RATIO_NUM(nout->node)=rval_num;
  524.     RATIO_DEN(nout->node)=rval_den;
  525.     return;
  526.  }
  527.  TYPE(nout->node)|=NT_IS_VALUE+NT_REAL;
  528.  REAL(nout->node)=realval;
  529. }
  530.  
  531.  
  532. void lf_plusone LF_PARAMS
  533. {
  534.  if(IS_CONS(nin)){
  535.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  536.    nin=calc_pointer(nout);
  537.    if(IS_VALUE_AND_NUMBER(nin)){
  538.      nout->type=P_ALLNODE;
  539.      switch(GET_VTYPE(nin)){
  540.        case NT_INTEGER:
  541.      TYPE(nout->node=node_make())|=NT_IS_VALUE+NT_INTEGER;
  542.          INTEGER(nout->node)=INTEGER(nin)+1;
  543.          return;
  544.        case NT_RATIO:
  545.      TYPE(nout->node=node_make())|=NT_IS_VALUE+NT_RATIO;
  546.          RATIO_NUM(nout->node)=RATIO_NUM(nin)+RATIO_DEN(nin);
  547.          RATIO_DEN(nout->node)=RATIO_DEN(nin);
  548.          return;
  549.        case NT_REAL:
  550.      TYPE(nout->node=node_make())|=NT_IS_VALUE+NT_REAL;
  551.          REAL(nout->node)=REAL(nin)+1;
  552.          return;
  553.      }
  554.    }
  555.    error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  556.  }
  557.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  558. }
  559.  
  560.  
  561. void lf_minusone LF_PARAMS
  562. {
  563.  if(IS_CONS(nin)){
  564.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  565.    nin=calc_pointer(nout);
  566.    if(IS_VALUE_AND_NUMBER(nin)){
  567.      nout->type=P_ALLNODE;
  568.      switch(GET_VTYPE(nin)){
  569.        case NT_INTEGER:
  570.      TYPE(nout->node=node_make())|=NT_IS_VALUE+NT_INTEGER;
  571.          INTEGER(nout->node)=INTEGER(nin)-1;
  572.          return;
  573.        case NT_RATIO:
  574.      TYPE(nout->node=node_make())|=NT_IS_VALUE+NT_RATIO;
  575.          RATIO_NUM(nout->node)=RATIO_NUM(nin)-RATIO_DEN(nin);
  576.          RATIO_DEN(nout->node)=RATIO_DEN(nin);
  577.          return;
  578.        case NT_REAL:
  579.      TYPE(nout->node=node_make())|=NT_IS_VALUE+NT_REAL;
  580.          REAL(nout->node)=REAL(nin)-1;
  581.          return;
  582.      }
  583.    }
  584.    error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  585.  }
  586.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  587. }
  588.  
  589.  
  590.  
  591.  
  592.  
  593.  
  594.  
  595. #define TF_FIRST 1
  596.  
  597.  
  598. void lf_max LF_PARAMS
  599. {
  600.  /* ritorna il massimo tra gli argomenti */
  601.  
  602.  REGISTER_MOD int    type_flag=TF_FIRST;
  603.  REGISTER_MOD n_type t;
  604.  n_int  last_int;
  605.  n_real last_real;
  606.  n_real tmp;
  607.  node    n;
  608.  node   max=NIL;
  609.  
  610.    while(IS_CONS(nin)){
  611.       eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  612.       if( (t=TYPE(n=calc_pointer(nout)))&NT_IS_VALUE){
  613.          switch(t&NT_MASK){
  614.              case NT_INTEGER:
  615.                 switch(type_flag){
  616.                    case TF_FIRST:
  617.                       type_flag=TF_INT;
  618.                       last_int=INTEGER(n);
  619.                       max=n;
  620.                       nin=CONSRIGHT(nin);
  621.                       continue;
  622.                    case TF_INT:
  623.                       if(last_int<INTEGER(n)){
  624.                         last_int=INTEGER(n);
  625.                         max=n;
  626.                       }
  627.                       nin=CONSRIGHT(nin);
  628.                       continue;
  629.                    case TF_FLO:
  630.               if(last_real<(n_real)INTEGER(n)){
  631.                         last_real=(n_real)INTEGER(n);
  632.                         max=n;
  633.                       }
  634.                       nin=CONSRIGHT(nin);
  635.                       continue;
  636.                 }
  637.              case NT_RATIO:
  638.                 switch(type_flag){
  639.                    case TF_FIRST:
  640.                       last_real=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  641.                       type_flag=TF_FLO;
  642.                       max=n;
  643.                       nin=CONSRIGHT(nin);
  644.                       continue;
  645.                    case TF_INT:
  646.                       tmp=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  647.                       if((n_real)last_int<tmp){
  648.                         last_real=tmp;
  649.                         type_flag=TF_FLO;
  650.                         max=n;
  651.                       }
  652.                       nin=CONSRIGHT(nin);
  653.                       continue;
  654.                    case TF_FLO:
  655.                       tmp=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  656.                       if(last_real<tmp){
  657.                         last_real=tmp;
  658.                         max=n;
  659.                       }
  660.                       nin=CONSRIGHT(nin);
  661.                       continue;
  662.                 }
  663.              case NT_REAL:
  664.                 switch(type_flag){
  665.                    case TF_FIRST:
  666.                       last_real=REAL(n);
  667.                       type_flag=TF_FLO;
  668.                       max=n;
  669.                       nin=CONSRIGHT(nin);
  670.                       continue;
  671.                    case TF_INT:
  672.                       if((n_real)last_int<REAL(n)){
  673.                         last_real=REAL(n);
  674.                         type_flag=TF_FLO;
  675.                         max=n;
  676.                       }
  677.                       nin=CONSRIGHT(nin);
  678.                       continue;
  679.                    case TF_FLO:
  680.                       if(last_real<REAL(n)){
  681.                         last_real=REAL(n);
  682.                         max=n;
  683.                       }
  684.                       nin=CONSRIGHT(nin);
  685.                       continue;
  686.                 }
  687.              default:
  688.                error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  689.          }/* switch */
  690.       }/* if is-value */
  691.       error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  692.    }/* while */
  693.  nout->type=P_ALLNODE;
  694.  nout->node=max;
  695. }
  696.  
  697.  
  698. void lf_min LF_PARAMS
  699. {
  700.  /* ritorna il minimo tra gli argomenti */
  701.  
  702.  REGISTER_MOD int    type_flag=TF_FIRST;
  703.  REGISTER_MOD n_type t;
  704.  n_int  last_int;
  705.  n_real last_real;
  706.  n_real tmp;
  707.  node    n;
  708.  node   max=NIL;
  709.  
  710.    while(IS_CONS(nin)){
  711.       eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  712.       if( (t=TYPE(n=calc_pointer(nout)))&NT_IS_VALUE){
  713.          switch(t&NT_MASK){
  714.              case NT_INTEGER:
  715.                 switch(type_flag){
  716.                    case TF_FIRST:
  717.                       type_flag=TF_INT;
  718.                       last_int=INTEGER(n);
  719.                       max=n;
  720.                       nin=CONSRIGHT(nin);
  721.                       continue;
  722.                    case TF_INT:
  723.                       if(last_int>INTEGER(n)){
  724.                         last_int=INTEGER(n);
  725.                         max=n;
  726.                       }
  727.                       nin=CONSRIGHT(nin);
  728.                       continue;
  729.                    case TF_FLO:
  730.               if(last_real>(n_real)INTEGER(n)){
  731.                         last_real=(n_real)INTEGER(n);
  732.                         max=n;
  733.                       }
  734.                       nin=CONSRIGHT(nin);
  735.                       continue;
  736.                 }
  737.              case NT_RATIO:
  738.                 switch(type_flag){
  739.                    case TF_FIRST:
  740.                       last_real=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  741.                       type_flag=TF_FLO;
  742.                       max=n;
  743.                       nin=CONSRIGHT(nin);
  744.                       continue;
  745.                    case TF_INT:
  746.                       tmp=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  747.                       if((n_real)last_int>tmp){
  748.                         last_real=tmp;
  749.                         type_flag=TF_FLO;
  750.                         max=n;
  751.                       }
  752.                       nin=CONSRIGHT(nin);
  753.                       continue;
  754.                    case TF_FLO:
  755.                       tmp=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  756.                       if(last_real>tmp){
  757.                         last_real=tmp;
  758.                         max=n;
  759.                       }
  760.                       nin=CONSRIGHT(nin);
  761.                       continue;
  762.                 }
  763.              case NT_REAL:
  764.                 switch(type_flag){
  765.                    case TF_FIRST:
  766.                       last_real=REAL(n);
  767.                       type_flag=TF_FLO;
  768.                       max=n;
  769.                       nin=CONSRIGHT(nin);
  770.                       continue;
  771.                    case TF_INT:
  772.                       if((n_real)last_int>REAL(n)){
  773.                         last_real=REAL(n);
  774.                         type_flag=TF_FLO;
  775.                         max=n;
  776.                       }
  777.                       nin=CONSRIGHT(nin);
  778.                       continue;
  779.                    case TF_FLO:
  780.                       if(last_real>REAL(n)){
  781.             last_real=REAL(n);
  782.                         max=n;
  783.                       }
  784.                       nin=CONSRIGHT(nin);
  785.                       continue;
  786.                 }
  787.              default:
  788.                error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  789.          }/* switch */
  790.       }/* if is-value */
  791.       error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  792.    }/* while */
  793.  nout->type=P_ALLNODE;
  794.  nout->node=max;
  795. }
  796.  
  797.  
  798. void lf_abs LF_PARAMS
  799. {
  800.  /* sintassi (abs numero) */
  801.  
  802.  if(IS_CONS(nin)){
  803.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  804.    nin=calc_pointer(nout);
  805.    if( IS_VALUE_AND_NUMBER(nin) ){
  806.      nout->node=node_make();
  807.      nout->type=P_ALLNODE;
  808.      switch(GET_VTYPE(nin)){
  809.        case NT_INTEGER:
  810.          INTEGER(nout->node)=INTEGER(nin)>0?INTEGER(nin):-INTEGER(nin);
  811.          TYPE(nout->node)|=NT_IS_VALUE+NT_INTEGER;
  812.          return;
  813.        case NT_REAL:
  814.          REAL(nout->node)=fabs(REAL(nin));
  815.          TYPE(nout->node)|=NT_IS_VALUE+NT_REAL;
  816.          return;
  817.        case NT_RATIO:
  818.          RATIO_NUM(nout->node)=RATIO_NUM(nin)>0?RATIO_NUM(nin):-RATIO_NUM(nin);
  819.          RATIO_DEN(nout->node)=RATIO_DEN(nin)>0?RATIO_DEN(nin):-RATIO_DEN(nin);
  820.          TYPE(nout->node)|=NT_IS_VALUE+NT_RATIO;
  821.      return;
  822.      }
  823.    }
  824.    error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  825.  }
  826.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  827. }
  828.  
  829. void lf_float LF_PARAMS
  830. {
  831.  /* sintassi (float numero) */
  832.  
  833.  if(IS_CONS(nin)){
  834.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  835.    nin=calc_pointer(nout);
  836.    if( IS_VALUE_AND_NUMBER(nin) ){
  837.      nout->node=node_make();
  838.      nout->type=P_ALLNODE;
  839.      TYPE(nout->node)|=NT_IS_VALUE+NT_REAL;
  840.      switch(GET_VTYPE(nin)){
  841.        case NT_INTEGER:
  842.          REAL(nout->node)=(n_real)INTEGER(nin);
  843.          return;
  844.        case NT_REAL:
  845.          REAL(nout->node)=REAL(nin);
  846.          return;
  847.        case NT_RATIO:
  848.          REAL(nout->node)=(n_real)RATIO_NUM(nin)/(n_real)RATIO_DEN(nin);
  849.          return;
  850.      }
  851.    }
  852.    error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  853.  }
  854.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  855. }
  856.  
  857. void lf_round LF_PARAMS
  858. {
  859.  /* sintassi (round numero) */
  860.  
  861.  if(IS_CONS(nin)){
  862.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  863.    nin=calc_pointer(nout);
  864.    if( IS_VALUE_AND_NUMBER(nin) ){
  865.      nout->node=node_make();
  866.      nout->type=P_ALLNODE;
  867.      TYPE(nout->node)|=NT_IS_VALUE+NT_INTEGER;
  868.      switch(GET_VTYPE(nin)){
  869.        case NT_INTEGER:
  870.          INTEGER(nout->node)=INTEGER(nin);
  871.          return;
  872.        case NT_REAL:
  873.          INTEGER(nout->node)=(n_int)REAL(nin);
  874.          return;
  875.        case NT_RATIO:
  876.          INTEGER(nout->node)=RATIO_NUM(nin)/RATIO_DEN(nin);
  877.          return;
  878.      }
  879.    }
  880.    error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  881.  }
  882.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  883. }
  884.  
  885. void lf_rem LF_PARAMS
  886. {
  887.  /* sintassi (rem numero) */
  888.  double tmp;
  889.  
  890.  if(IS_CONS(nin)){
  891.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  892.    nin=calc_pointer(nout);
  893.    if( IS_VALUE_AND_NUMBER(nin) ){
  894.      nout->node=node_make();
  895.      nout->type=P_ALLNODE;
  896.      switch(GET_VTYPE(nin)){
  897.        case NT_INTEGER:
  898.          INTEGER(nout->node)=(n_int)0;
  899.          TYPE(nout->node)|=NT_IS_VALUE+NT_INTEGER;
  900.          return;
  901.        case NT_REAL:
  902.          REAL(nout->node)=modf(REAL(nin),&tmp);
  903.          TYPE(nout->node)|=NT_IS_VALUE+NT_REAL;
  904.          return;
  905.        case NT_RATIO:
  906.          if(RATIO_NUM(nin)>RATIO_DEN(nin)){
  907.            RATIO_NUM(nout->node)=RATIO_NUM(nin)-RATIO_DEN(nin);
  908.          }else{
  909.            RATIO_NUM(nout->node)=RATIO_NUM(nin);
  910.          }
  911.          RATIO_DEN(nout->node)=RATIO_DEN(nin);
  912.          TYPE(nout->node)|=NT_IS_VALUE+NT_RATIO;
  913.          return;
  914.      }
  915.    }
  916.    error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  917.  }
  918.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  919. }
  920.  
  921.